home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / dasyik.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  7.8 KB  |  150 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((con (make-array 2 :element-type 'double-float))
  12.       (c (make-array 65 :element-type 'double-float)))
  13.   (declare (type (array double-float (65)) c)
  14.            (type (array double-float (2)) con))
  15.   (f2cl-lib:fset (f2cl-lib:fref con (1) ((1 2))) 0.3989422804014327)
  16.   (f2cl-lib:fset (f2cl-lib:fref con (2) ((1 2))) 1.2533141373155003)
  17.   (f2cl-lib:fset (f2cl-lib:fref c (1) ((1 65))) -0.208333333333333)
  18.   (f2cl-lib:fset (f2cl-lib:fref c (2) ((1 65))) 0.125)
  19.   (f2cl-lib:fset (f2cl-lib:fref c (3) ((1 65))) 0.33420138888888906)
  20.   (f2cl-lib:fset (f2cl-lib:fref c (4) ((1 65))) -0.40104166666666696)
  21.   (f2cl-lib:fset (f2cl-lib:fref c (5) ((1 65))) 0.0703125)
  22.   (f2cl-lib:fset (f2cl-lib:fref c (6) ((1 65))) -1.02581259645062)
  23.   (f2cl-lib:fset (f2cl-lib:fref c (7) ((1 65))) 1.84646267361111)
  24.   (f2cl-lib:fset (f2cl-lib:fref c (8) ((1 65))) -0.8912109375)
  25.   (f2cl-lib:fset (f2cl-lib:fref c (9) ((1 65))) 0.0732421875)
  26.   (f2cl-lib:fset (f2cl-lib:fref c (10) ((1 65))) 4.66958442342625)
  27.   (f2cl-lib:fset (f2cl-lib:fref c (11) ((1 65))) -11.207002616223)
  28.   (f2cl-lib:fset (f2cl-lib:fref c (12) ((1 65))) 8.78912353515625)
  29.   (f2cl-lib:fset (f2cl-lib:fref c (13) ((1 65))) -2.3640869140625)
  30.   (f2cl-lib:fset (f2cl-lib:fref c (14) ((1 65))) 0.112152099609375)
  31.   (f2cl-lib:fset (f2cl-lib:fref c (15) ((1 65))) -28.2120725582002)
  32.   (f2cl-lib:fset (f2cl-lib:fref c (16) ((1 65))) 84.6362176746007)
  33.   (f2cl-lib:fset (f2cl-lib:fref c (17) ((1 65))) -91.81824154323999)
  34.   (f2cl-lib:fset (f2cl-lib:fref c (18) ((1 65))) 42.5349987453885)
  35.   (f2cl-lib:fset (f2cl-lib:fref c (19) ((1 65))) -7.36879435947963)
  36.   (f2cl-lib:fset (f2cl-lib:fref c (20) ((1 65))) 0.22710800170898404)
  37.   (f2cl-lib:fset (f2cl-lib:fref c (21) ((1 65))) 212.57013003921702)
  38.   (f2cl-lib:fset (f2cl-lib:fref c (22) ((1 65))) -765.252468141182)
  39.   (f2cl-lib:fset (f2cl-lib:fref c (23) ((1 65))) 1059.9904525279999)
  40.   (f2cl-lib:fset (f2cl-lib:fref c (24) ((1 65))) -699.5796273761331)
  41.   (f2cl-lib:fset (f2cl-lib:fref c (25) ((1 65))) 218.190511744212)
  42.   (f2cl-lib:fset (f2cl-lib:fref c (26) ((1 65))) -26.4914304869516)
  43.   (f2cl-lib:fset (f2cl-lib:fref c (27) ((1 65))) 0.572501420974731)
  44.   (f2cl-lib:fset (f2cl-lib:fref c (28) ((1 65))) -1919.45766231841)
  45.   (f2cl-lib:fset (f2cl-lib:fref c (29) ((1 65))) 8061.722181737309)
  46.   (f2cl-lib:fset (f2cl-lib:fref c (30) ((1 65))) -13586.5500064341)
  47.   (f2cl-lib:fset (f2cl-lib:fref c (31) ((1 65))) 11655.3933368645)
  48.   (f2cl-lib:fset (f2cl-lib:fref c (32) ((1 65))) -5305.6469786134)
  49.   (f2cl-lib:fset (f2cl-lib:fref c (33) ((1 65))) 1200.90291321635)
  50.   (f2cl-lib:fset (f2cl-lib:fref c (34) ((1 65))) -108.090919788395)
  51.   (f2cl-lib:fset (f2cl-lib:fref c (35) ((1 65))) 1.72772750258446)
  52.   (f2cl-lib:fset (f2cl-lib:fref c (36) ((1 65))) 20204.2913309661)
  53.   (f2cl-lib:fset (f2cl-lib:fref c (37) ((1 65))) -96980.5983886375)
  54.   (f2cl-lib:fset (f2cl-lib:fref c (38) ((1 65))) 192547.001232532)
  55.   (f2cl-lib:fset (f2cl-lib:fref c (39) ((1 65))) -203400.177280416)
  56.   (f2cl-lib:fset (f2cl-lib:fref c (40) ((1 65))) 122200.464983017)
  57.   (f2cl-lib:fset (f2cl-lib:fref c (41) ((1 65))) -41192.6549688976)
  58.   (f2cl-lib:fset (f2cl-lib:fref c (42) ((1 65))) 7109.51430248936)
  59.   (f2cl-lib:fset (f2cl-lib:fref c (43) ((1 65))) -493.915304773088)
  60.   (f2cl-lib:fset (f2cl-lib:fref c (44) ((1 65))) 6.07404200127348)
  61.   (f2cl-lib:fset (f2cl-lib:fref c (45) ((1 65))) -242919.187900551)
  62.   (f2cl-lib:fset (f2cl-lib:fref c (46) ((1 65))) 1311763.6146629802)
  63.   (f2cl-lib:fset (f2cl-lib:fref c (47) ((1 65))) -2998015.9185381103)
  64.   (f2cl-lib:fset (f2cl-lib:fref c (48) ((1 65))) 3763271.2976564)
  65.   (f2cl-lib:fset (f2cl-lib:fref c (49) ((1 65))) -2813563.22658653)
  66.   (f2cl-lib:fset (f2cl-lib:fref c (50) ((1 65))) 1268365.27332162)
  67.   (f2cl-lib:fset (f2cl-lib:fref c (51) ((1 65))) -331645.172484564)
  68.   (f2cl-lib:fset (f2cl-lib:fref c (52) ((1 65))) 45218.7689813627)
  69.   (f2cl-lib:fset (f2cl-lib:fref c (53) ((1 65))) -2499.8304818112097)
  70.   (f2cl-lib:fset (f2cl-lib:fref c (54) ((1 65))) 24.3805296995561)
  71.   (f2cl-lib:fset (f2cl-lib:fref c (55) ((1 65))) 3284469.8530720402)
  72.   (f2cl-lib:fset (f2cl-lib:fref c (56) ((1 65))) -1.9706819118432198e+7)
  73.   (f2cl-lib:fset (f2cl-lib:fref c (57) ((1 65))) 5.09526024926646e+7)
  74.   (f2cl-lib:fset (f2cl-lib:fref c (58) ((1 65))) -7.41051482115327e+7)
  75.   (f2cl-lib:fset (f2cl-lib:fref c (59) ((1 65))) 6.634451227472901e+7)
  76.   (f2cl-lib:fset (f2cl-lib:fref c (60) ((1 65))) -3.7567176660763396e+7)
  77.   (f2cl-lib:fset (f2cl-lib:fref c (61) ((1 65))) 1.32887671664218e+7)
  78.   (f2cl-lib:fset (f2cl-lib:fref c (62) ((1 65))) -2785618.12808645)
  79.   (f2cl-lib:fset (f2cl-lib:fref c (63) ((1 65))) 308186.404612662)
  80.   (f2cl-lib:fset (f2cl-lib:fref c (64) ((1 65))) -13886.089753716999)
  81.   (f2cl-lib:fset (f2cl-lib:fref c (65) ((1 65))) 110.01714026924701)
  82.   (defun dasyik (x fnu kode flgik ra arg in y)
  83.     (declare (type (array double-float (*)) y)
  84.              (type f2cl-lib:integer4 in kode)
  85.              (type double-float arg ra flgik fnu x))
  86.     (f2cl-lib:with-array-data (y-%data% y-%offset% y)
  87.       (declare (type f2cl-lib:integer4 y-%offset%)
  88.                (type (simple-array double-float (*)) y-%data%)
  89.                (ignorable y-%offset% y-%data%))
  90.       (prog ((ak 0.0) (ap 0.0) (coef 0.0) (etx 0.0) (fn 0.0) (gln 0.0) (s1 0.0)
  91.              (s2 0.0) (t_ 0.0) (tol 0.0) (t2 0.0) (z 0.0) (j 0) (jn 0) (k 0)
  92.              (kk 0) (l 0))
  93.         (declare (type f2cl-lib:integer4 l kk k jn j)
  94.                  (type double-float z t2 tol t_ s2 s1 gln fn etx coef ap ak))
  95.         (setf tol (f2cl-lib:d1mach 3))
  96.         (setf tol (max tol 1.0000000000000002e-15))
  97.         (setf fn fnu)
  98.         (setf z (/ (- 3.0 flgik) 2.0))
  99.         (setf kk (f2cl-lib:int z))
  100.         (f2cl-lib:fdo (jn 1 (f2cl-lib:int-add jn 1))
  101.                       ((> jn in) nil)
  102.           (tagbody
  103.             (if (= jn 1) (go label10))
  104.             (setf fn (- fn flgik))
  105.             (setf z (/ x fn))
  106.             (setf ra (f2cl-lib:fsqrt (+ 1.0 (* z z))))
  107.             (setf gln (f2cl-lib:flog (/ (+ 1.0 ra) z)))
  108.             (setf etx
  109.                     (coerce (the f2cl-lib:integer4 (f2cl-lib:int-sub kode 1))
  110.                             'double-float))
  111.             (setf t_ (+ (* ra (- 1.0 etx)) (/ etx (+ z ra))))
  112.             (setf arg (* fn (- t_ gln) flgik))
  113.            label10
  114.             (setf coef (exp arg))
  115.             (setf t_ (/ 1.0 ra))
  116.             (setf t2 (* t_ t_))
  117.             (setf t_ (/ t_ fn))
  118.             (setf t_ (f2cl-lib:sign t_ flgik))
  119.             (setf s2 1.0)
  120.             (setf ap 1.0)
  121.             (setf l 0)
  122.             (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1))
  123.                           ((> k 11) nil)
  124.               (tagbody
  125.                 (setf l (f2cl-lib:int-add l 1))
  126.                 (setf s1 (f2cl-lib:fref c (l) ((1 65))))
  127.                 (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1))
  128.                               ((> j k) nil)
  129.                   (tagbody
  130.                     (setf l (f2cl-lib:int-add l 1))
  131.                     (setf s1 (+ (* s1 t2) (f2cl-lib:fref c (l) ((1 65)))))
  132.                    label20))
  133.                 (setf ap (* ap t_))
  134.                 (setf ak (* ap s1))
  135.                 (setf s2 (+ s2 ak))
  136.                 (if (< (max (abs ak) (abs ap)) tol) (go label40))
  137.                label30))
  138.            label40
  139.             (setf t_ (coerce (abs t_) 'double-float))
  140.             (f2cl-lib:fset (f2cl-lib:fref y-%data% (jn) ((1 *)) y-%offset%)
  141.                            (* s2
  142.                               coef
  143.                               (f2cl-lib:fsqrt t_)
  144.                               (f2cl-lib:fref con (kk) ((1 2)))))
  145.            label50))
  146.         (go end_label)
  147.        end_label
  148.         (return (values nil nil nil nil ra arg nil nil))))))
  149.  
  150.